home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / TSPA3450 / TSUNTM.TST < prev    next >
Text File  |  1994-08-16  |  5KB  |  195 lines
  1. {$M 16384,0,655360}
  2.  
  3. (* This is a test program for the TSUNTM.TPU unit *)
  4.  
  5. uses Dos,
  6.      TSUNTH,  (* to have access to keyboad type *)
  7.      TSUNTM;
  8.  
  9. procedure LOGO;
  10. begin
  11.   writeln;
  12.   writeln ('TSUNTG unit test by Prof. Timo Salmi');
  13.   writeln ('University of Vaasa, Finland, ts@uwasa.fi');
  14. {$IFDEF VER40}
  15.   writeln ('TP version 4.0');
  16. {$ENDIF}
  17. {$IFDEF VER50}
  18.   writeln ('TP version 5.0');
  19. {$ENDIF}
  20. {$IFDEF VER55}
  21.   writeln ('TP version 5.5');
  22. {$ENDIF}
  23. {$IFDEF VER60}
  24.   writeln ('TP version 6.0');
  25. {$ENDIF}
  26. {$IFDEF VER70}
  27.   writeln ('TP version 7.0');
  28. {$ENDIF}
  29.   writeln;
  30. end;
  31.  
  32. (* Test of the timed inkey function *)
  33. procedure TEST1;
  34. var key : char;
  35.     timeout : boolean;
  36. begin
  37.   repeat
  38.     key := INKEYFN (3.0, timeout);
  39.     if not timeout then write (key)
  40.       else begin writeln; writeln ('Timeout',#7); end;
  41.   until key = #27;
  42. end;  (* test1 *)
  43.  
  44. (* Detect special keys, and normal keyboard scancodes. Note that depending
  45.    on the keyboard some of the tests below can be mutually exclusive.
  46.    CTLFN excludes detecting RTCTRLFN, LFCTRLFN, and SYSRQFN. ALTFN excludes
  47.    FLATLFN. *)
  48. procedure TEST2;
  49. var ch : char;
  50. begin
  51.   writeln ('Esc to exit');
  52.   repeat
  53.     if LFSHFTFN then write ('LfShift ');
  54.     if RTSHFTFN then write ('RtShift ');
  55.     {}
  56.     if ISENHAFN then
  57.        begin
  58.          if LFCTRLFN then write ('LfCtrl ');
  59.          if RTCTRLFN then write ('RtCtrl ');
  60.        end
  61.      else
  62.        if CTRLFN then write ('Ctrl ');
  63.     {}
  64.     if ISENHAFN then
  65.        if LFALTFN  then write ('LfAlt ')
  66.          else                               (* Notice the else else trick *)
  67.       else
  68.          if ALTFN    then write ('Alt ');
  69.     {}
  70.     if RTALTFN  then write ('RtAlt ');
  71.     if SYSRQFN  then write ('SysRq ');
  72.     if KEYPREFN then
  73.       begin
  74.         ch := READKEFN;
  75.         case ch of
  76.           #0  : begin
  77.                   write (byte(ch), ' ');    (* ord(ch) is ok, too *)
  78.                   ch := READKEFN;           (* byte(ch) is an just an *)
  79.                   write (byte(ch), ' ');    (* example of typecasting *)
  80.                 end;
  81.           #27 : exit;
  82.           else write (byte(ch), ' ');
  83.         end; {case}
  84.       end; {if}
  85.   until false;
  86. end;  (* test2 *)
  87.  
  88. (* Test for the shift keys *)
  89. procedure TEST3;
  90. var ch : char;
  91.     changed : boolean;
  92. begin
  93.   writeln ('Esc to exit');
  94.   changed := true;
  95.   repeat
  96.     if LFSHFTFN then
  97.       if changed then
  98.         begin
  99.           write ('LfShiftDown ');
  100.           changed := false;
  101.         end
  102.       else
  103.     else
  104.       changed := true;
  105.     {}
  106.     if KEYPREFN then
  107.       begin
  108.         ch := READKEFN;
  109.         case ch of
  110.           #27 : exit;
  111.         end; {case}
  112.       end; {if}
  113.   until false;
  114. end;  (* test3 *)
  115.  
  116. (* Test reading enhanced keyboard keys. Notice the trick to get the
  117.    low and the high parts of a Turbo Pascal word *)
  118. procedure TEST4;
  119. var scancode : word;
  120.     key      : array [1..2] of byte absolute scancode;
  121. begin
  122.   repeat
  123.     scancode := RDENKEFN;
  124.     {}
  125.     {... show the first part of the scancode ...}
  126.     write (key[1], ' ');
  127.     {}
  128.     {... enhanced keys have also a second part in the scancode ...}
  129.     case key[1] of
  130.       0, 224 : write (key[2], ' ');
  131.     end;
  132.   until (key[1] = 27)                 (* escape with esc *)
  133.          or (scancode = 0);           (* not an enhanced keyboard *)
  134. end;  (* test4 *)
  135.  
  136. (* Display the ascii value and the scancode of the key pressed *)
  137. procedure TEST5;
  138. var scanCode : byte;
  139.     charCode : byte;
  140.     s        : string;
  141. begin
  142.   writeln ('Press Esc to end this folly');
  143.   writeln;
  144.   repeat
  145.     GETSCAN (scanCode, charCode);
  146.     case charCode of
  147.       0..31, 129..255 : begin
  148.                           Str(charCode, s);
  149.                           s := 'asc(' + s + ')';
  150.                         end;
  151.       else s := chr(charCode)
  152.     end; {case}
  153.     writeln (s, ' scancode = ', scancode:3);
  154.   until scancode = 1;
  155. end;  (* test5 *)
  156.  
  157. (* Display the ascii value and the scancode of the key pressed for
  158.    the enhanced keyboard with GETESCAN. To test the presence of an
  159.    enhanced keyboard use ISENHAFN from the TSUNTH unit *)
  160. procedure TEST6;
  161. var scanCode : byte;
  162.     charCode : byte;
  163.     s        : string;
  164. begin
  165.   writeln ('Press Esc to end this folly');
  166.   writeln;
  167.   repeat
  168.     GETESCAN (scanCode, charCode);
  169.     case charCode of
  170.       0..31, 129..255 : begin
  171.                           Str(charCode, s);
  172.                           s := 'asc(' + s + ')';
  173.                         end;
  174.       else s := chr(charCode)
  175.     end; {case}
  176.     writeln (s, ' scancode = ', scancode:3);
  177.   until scancode = 1;
  178. end;  (* test6 *)
  179.  
  180. (* Main program
  181.    If you just want a particular test, comment the others away, just as
  182.    I have done.
  183.    If you want pauses, put readln where appropriate *)
  184. begin
  185.   LOGO;
  186.   TEST1;
  187.   TEST2;
  188.   TEST3;
  189.   TEST4;
  190.   TEST5;
  191.   TEST6;
  192.   {}
  193.   write ('Press <-'' '); readln;
  194. end.  (* tsuntm.tst *)
  195.